home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / url.el.z / url.el
Encoding:
Text File  |  1998-05-21  |  72.3 KB  |  2,107 lines
  1. ;;; url.el --- Uniform Resource Locator retrieval tool
  2. ;; Author: wmperry
  3. ;; Created: 1997/12/25 23:53:39
  4. ;; Version: 1.88
  5. ;; Keywords: comm, data, processes, hypermedia
  6.  
  7. ;;; LCD Archive Entry:
  8. ;;; url|William M. Perry|wmperry@cs.indiana.edu|
  9. ;;; Functions for retrieving/manipulating URLs|
  10. ;;; 1997/12/25 23:53:39|1.88|Location Undetermined
  11. ;;;
  12.  
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ;;; Copyright (c) 1993-1996 by William M. Perry <wmperry@cs.indiana.edu>
  15. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  16. ;;;
  17. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  18. ;;;
  19. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  20. ;;; it under the terms of the GNU General Public License as published by
  21. ;;; the Free Software Foundation; either version 2, or (at your option)
  22. ;;; any later version.
  23. ;;;
  24. ;;; GNU Emacs is distributed in the hope that it will be useful,
  25. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  26. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  27. ;;; GNU General Public License for more details.
  28. ;;;
  29. ;;; You should have received a copy of the GNU General Public License
  30. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  31. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  32. ;;; Boston, MA 02111-1307, USA.
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34.  
  35.  
  36. (require 'cl)
  37. (require 'url-vars)
  38. (require 'url-parse)
  39. (require 'mm)
  40. (require 'mule-sysdp)
  41. (require 'devices)
  42. (or (featurep 'efs)
  43.     (featurep 'efs-auto)
  44.     (condition-case ()
  45.     (require 'ange-ftp)
  46.       (error nil)))
  47.  
  48. (eval-and-compile
  49.   (if (not (and (string-match "XEmacs" emacs-version)
  50.         (or (> emacs-major-version 19)
  51.             (>= emacs-minor-version 14))))
  52.       (require 'w3-sysdp)))
  53.  
  54. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55. ;;; Functions that might not exist in old versions of emacs
  56. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57. (defun url-save-error (errobj)
  58.   (save-excursion
  59.     (set-buffer (get-buffer-create " *url-error*"))
  60.     (erase-buffer))
  61.   (display-error errobj (get-buffer-create " *url-error*")))
  62.  
  63. (cond
  64.  ((fboundp 'display-warning)
  65.   (fset 'url-warn 'display-warning))
  66.  ((fboundp 'w3-warn)
  67.   (fset 'url-warn 'w3-warn))
  68.  ((fboundp 'warn)
  69.   (defun url-warn (class message &optional level)
  70.     (warn "(%s/%s) %s" class (or level 'warning) message)))
  71.  (t
  72.   (defun url-warn (class message &optional level)
  73.     (save-excursion
  74.       (set-buffer (get-buffer-create "*W3-WARNINGS*"))
  75.       (goto-char (point-max))
  76.       (save-excursion
  77.     (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
  78.       (display-buffer (current-buffer))))))
  79.  
  80.  
  81. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82. ;;; Autoload all the URL loaders
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84. (autoload 'url-file "url-file")
  85. (autoload 'url-ftp "url-file")
  86. (autoload 'url-gopher "url-gopher")
  87. (autoload 'url-irc "url-irc")
  88. (autoload 'url-http "url-http")
  89. (autoload 'url-nfs "url-nfs")
  90. (autoload 'url-mailserver "url-mail")
  91. (autoload 'url-mailto "url-mail")
  92. (autoload 'url-mail "url-mail")
  93. (autoload 'url-info "url-misc")
  94. (autoload 'url-shttp "url-http")
  95. (autoload 'url-https "url-http")
  96. (autoload 'url-data "url-misc")
  97. (autoload 'url-finger "url-misc")
  98. (autoload 'url-rlogin "url-misc")
  99. (autoload 'url-telnet "url-misc")
  100. (autoload 'url-tn3270 "url-misc")
  101. (autoload 'url-proxy "url-misc")
  102. (autoload 'url-netrek "url-misc")
  103. (autoload 'url-news "url-news")
  104. (autoload 'url-nntp "url-news")
  105.  
  106. (autoload 'url-open-stream "url-gw")
  107. (autoload 'url-mime-response-p "url-http")
  108. (autoload 'url-parse-mime-headers "url-http")
  109. (autoload 'url-handle-refresh-header "url-http")
  110. (autoload 'url-create-mime-request "url-http")
  111. (autoload 'url-create-message-id "url-http")
  112. (autoload 'url-create-multipart-request "url-http")
  113. (autoload 'url-parse-viewer-types "url-http")
  114.  
  115. (autoload 'url-get-authentication "url-auth")
  116. (autoload 'url-register-auth-scheme "url-auth")
  117. (autoload 'url-cookie-write-file "url-cookie")
  118. (autoload 'url-cookie-retrieve "url-cookie")
  119. (autoload 'url-cookie-generate-header-lines "url-cookie")
  120. (autoload 'url-cookie-handle-set-cookie "url-cookie")
  121.  
  122. (autoload 'url-is-cached "url-cache")
  123. (autoload 'url-store-in-cache "url-cache")
  124. (autoload 'url-is-cached "url-cache")
  125. (autoload 'url-cache-create-filename "url-cache")
  126. (autoload 'url-cache-extract "url-cache")
  127. (autoload 'url-cache-expired "url-cache")
  128.  
  129. (require 'md5)
  130. (require 'base64)
  131.  
  132. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  133. ;;; File-name-handler-alist functions
  134. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  135. (defun url-setup-file-name-handlers ()
  136.   ;; Setup file-name handlers.
  137.   '(cond
  138.     ((not (boundp 'file-name-handler-alist))
  139.      nil)                ; Don't load if no alist
  140.     ((rassq 'url-file-handler file-name-handler-alist)
  141.      nil)                ; Don't load twice
  142.     (t
  143.      (setq file-name-handler-alist
  144.        (let ((new-handler (cons
  145.                    (concat "^/*"
  146.                        (substring url-nonrelative-link1 nil))
  147.                    'url-file-handler)))
  148.          (if file-name-handler-alist
  149.          (append (list new-handler) file-name-handler-alist)
  150.            (list new-handler)))))))
  151.   
  152. (defun url-file-handler (operation &rest args)
  153.   ;; Function called from the file-name-handler-alist routines.  OPERATION
  154.   ;; is what needs to be done ('file-exists-p, etc).  args are the arguments
  155.   ;; that would have been passed to OPERATION."
  156.   (let ((fn (get operation 'url-file-handlers))
  157.     (url (car args))
  158.     (myargs (cdr args)))
  159.     (if (= (string-to-char url) ?/)
  160.     (setq url (substring url 1 nil)))
  161.     (if fn (apply fn url myargs)
  162.       (let (file-name-handler-alist)
  163.     (apply operation url myargs)))))
  164.  
  165. (defun url-file-handler-identity (&rest args)
  166.   (car args))
  167.  
  168. (defun url-file-handler-null (&rest args)
  169.   nil)
  170.  
  171. (put 'file-directory-p 'url-file-handlers 'url-file-handler-null)
  172. (put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity)
  173. (put 'file-writable-p 'url-file-handlers 'url-file-handler-null)
  174. (put 'file-truename 'url-file-handlers 'url-file-handler-identity)
  175. (put 'insert-file-contents 'url-file-handlers 'url-insert-file-contents)
  176. (put 'expand-file-name 'url-file-handlers 'url-expand-file-name)
  177. (put 'directory-files 'url-file-handlers 'url-directory-files)
  178. (put 'file-directory-p 'url-file-handlers 'url-file-directory-p)
  179. (put 'file-writable-p 'url-file-handlers 'url-file-writable-p)
  180. (put 'file-readable-p 'url-file-handlers 'url-file-exists)
  181. (put 'file-executable-p 'url-file-handlers 'null)
  182. (put 'file-symlink-p 'url-file-handlers 'null)
  183. (put 'file-exists-p 'url-file-handlers 'url-file-exists)
  184. (put 'copy-file 'url-file-handlers 'url-copy-file)
  185. (put 'file-attributes 'url-file-handlers 'url-file-attributes)
  186. (put 'file-name-all-completions 'url-file-handlers
  187.      'url-file-name-all-completions)
  188. (put 'file-name-completion 'url-file-handlers 'url-file-name-completion)
  189. (put 'file-local-copy 'url-file-handlers 'url-file-local-copy)
  190.  
  191.  
  192. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  193. ;;; Utility functions
  194. ;;; -----------------
  195. ;;; Various functions used around the url code.
  196. ;;; Some of these qualify as hacks, but hey, this is elisp.
  197. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  198.  
  199. (if (fboundp 'mm-string-to-tokens)
  200.     (fset 'url-string-to-tokens 'mm-string-to-tokens)
  201.   (defun url-string-to-tokens (str &optional delim)
  202.     "Return a list of words from the string STR"
  203.     (setq delim (or delim ? ))
  204.     (let (results y)
  205.       (mapcar
  206.        (function
  207.     (lambda (x)
  208.       (cond
  209.        ((and (= x delim) y) (setq results (cons y results) y nil))
  210.        ((/= x delim) (setq y (concat y (char-to-string x))))
  211.        (t nil)))) str)
  212.       (nreverse (cons y results)))))
  213.  
  214. (defun url-days-between (date1 date2)
  215.   ;; Return the number of days between date1 and date2.
  216.   (- (url-day-number date1) (url-day-number date2)))
  217.  
  218. (defun url-day-number (date)
  219.   (let ((dat (mapcar (function (lambda (s) (and s (string-to-int s)) ))
  220.              (timezone-parse-date date))))
  221.     (timezone-absolute-from-gregorian 
  222.      (nth 1 dat) (nth 2 dat) (car dat))))
  223.  
  224. (defun url-seconds-since-epoch (date)
  225.   ;; Returns a number that says how many seconds have
  226.   ;; lapsed between Jan 1 12:00:00 1970 and DATE."
  227.   (let* ((tdate (mapcar (function (lambda (ti) (and ti (string-to-int ti))))
  228.             (timezone-parse-date date)))
  229.      (ttime (mapcar (function (lambda (ti) (and ti (string-to-int ti))))
  230.             (timezone-parse-time
  231.              (aref (timezone-parse-date date) 3))))
  232.      (edate (mapcar (function (lambda (ti) (and ti (string-to-int ti))))
  233.             (timezone-parse-date "Jan 1 12:00:00 1970")))
  234.      (tday (- (timezone-absolute-from-gregorian 
  235.            (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
  236.           (timezone-absolute-from-gregorian 
  237.            (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
  238.     (+ (nth 2 ttime)
  239.        (* (nth 1 ttime) 60)
  240.        (* (nth 0 ttime) 60 60)
  241.        (* tday 60 60 24))))
  242.  
  243. (defun url-match (s x)
  244.   ;; Return regexp match x in s.
  245.   (substring s (match-beginning x) (match-end x)))
  246.  
  247. (defun url-split (str del)
  248.   ;; Split the string STR, with DEL (a regular expression) as the delimiter.
  249.   ;; Returns an assoc list that you can use with completing-read."
  250.   (let (x y)
  251.     (while (string-match del str)
  252.       (setq y (substring str 0 (match-beginning 0))
  253.         str (substring str (match-end 0) nil))
  254.       (if (not (string-match "^[ \t]+$" y))
  255.       (setq x (cons (list y y) x))))
  256.     (if (not (equal str ""))
  257.     (setq x (cons (list str str) x)))
  258.     x))
  259.  
  260. (defun url-replace-regexp (regexp to-string)
  261.   (goto-char (point-min))
  262.   (while (re-search-forward regexp nil t)
  263.     (replace-match to-string t nil)))
  264.  
  265. (defun url-clear-tmp-buffer ()
  266.   (set-buffer (get-buffer-create url-working-buffer))
  267.   (if buffer-read-only (toggle-read-only))
  268.   (erase-buffer))  
  269.  
  270. (defun url-maybe-relative (url)
  271.   (url-retrieve (url-expand-file-name url)))
  272.  
  273. (defun url-buffer-is-hypertext (&optional buff)
  274.   "Return t if a buffer contains HTML, as near as we can guess."
  275.   (setq buff (or buff (current-buffer)))
  276.   (save-excursion
  277.     (set-buffer buff)
  278.     (let ((case-fold-search t))
  279.       (goto-char (point-min))
  280.       (re-search-forward
  281.        "<\\(TITLE\\|HEAD\\|BASE\\|H[0-9]\\|ISINDEX\\|P\\)>" nil t))))
  282.  
  283. (defun url-percentage (x y)
  284.   (if (fboundp 'float)
  285.       (round (* 100 (/ x (float y))))
  286.     (/ (* x 100) y)))
  287.  
  288. (defun url-pretty-length (n)
  289.   (cond
  290.    ((< n 1024)
  291.     (format "%d bytes" n))
  292.    ((< n (* 1024 1024))
  293.     (format "%dk" (/ n 1024.0)))
  294.    (t
  295.     (format "%2.2fM" (/ n (* 1024 1024.0))))))
  296.  
  297. (defun url-after-change-function (&rest args)
  298.   ;; The nitty gritty details of messaging the HTTP/1.0 status messages
  299.   ;; in the minibuffer."
  300.   (or url-current-content-length
  301.       (save-excursion
  302.     (goto-char (point-min))
  303.     (skip-chars-forward " \t\n")
  304.     (if (not (looking-at "HTTP/[0-9]\.[0-9]"))
  305.         (setq url-current-content-length 0)
  306.       (setq url-current-isindex
  307.         (and (re-search-forward "$\r*$" nil t) (point)))
  308.       (if (re-search-forward
  309.            "^content-type:[ \t]*\\([^\r\n]+\\)\r*$"
  310.            url-current-isindex t)
  311.           (setq url-current-mime-type (downcase
  312.                        (url-eat-trailing-space
  313.                         (buffer-substring
  314.                          (match-beginning 1)
  315.                          (match-end 1))))))
  316.       (goto-char (point-min))
  317.       (if (re-search-forward "^content-length:\\([^\r\n]+\\)\r*$"
  318.                  url-current-isindex t)
  319.           (setq url-current-content-length
  320.             (string-to-int (buffer-substring (match-beginning 1)
  321.                              (match-end 1))))
  322.         (setq url-current-content-length nil))))
  323.       )
  324.   (let ((current-length (max (point-max)
  325.                  (if url-current-isindex
  326.                  (- (point-max) url-current-isindex)
  327.                    (point-max)))))
  328.     (cond
  329.      ((and url-current-content-length (> url-current-content-length 1)
  330.        url-current-mime-type)
  331.       (url-lazy-message "Reading [%s]... %s of %s (%d%%)"
  332.             url-current-mime-type
  333.             (url-pretty-length current-length)
  334.             (url-pretty-length url-current-content-length)
  335.             (url-percentage current-length
  336.                     url-current-content-length)))
  337.      ((and url-current-content-length (> url-current-content-length 1))
  338.       (url-lazy-message "Reading... %s of %s (%d%%)"
  339.             (url-pretty-length current-length)
  340.             (url-pretty-length url-current-content-length)
  341.             (url-percentage current-length
  342.                     url-current-content-length)))
  343.      ((and (/= 1 current-length) url-current-mime-type)
  344.       (url-lazy-message "Reading [%s]... %s"
  345.             url-current-mime-type
  346.             (url-pretty-length current-length)))
  347.      ((/= 1 current-length)
  348.       (url-lazy-message "Reading... %s."
  349.             (url-pretty-length current-length)))
  350.      (t (url-lazy-message "Waiting for response...")))))
  351.  
  352. (defun url-insert-entities-in-string (string)
  353.   "Convert HTML markup-start characters to entity references in STRING.
  354.   Also replaces the \" character, so that the result may be safely used as
  355.   an attribute value in a tag.  Returns a new string with the result of the
  356.   conversion.  Replaces these characters as follows:
  357.     &  ==>  &
  358.     <  ==>  <
  359.     >  ==>  >
  360.     \"  ==>  ""
  361.   (if (string-match "[&<>\"]" string)
  362.       (save-excursion
  363.     (set-buffer (get-buffer-create " *entity*"))
  364.     (erase-buffer)
  365.     (buffer-disable-undo (current-buffer))
  366.     (insert string)
  367.     (goto-char (point-min))
  368.     (while (progn
  369.          (skip-chars-forward "^&<>\"")
  370.          (not (eobp)))
  371.       (insert (cdr (assq (char-after (point))
  372.                  '((?\" . """)
  373.                    (?& . "&")
  374.                    (?< . "<")
  375.                    (?> . ">")))))
  376.       (delete-char 1))
  377.     (buffer-string))
  378.     string))
  379.  
  380. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  381. ;;; Information information
  382. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  383. (defvar url-process-lookup-table nil)
  384.  
  385. (defun url-process-get (proc prop &optional default)
  386.   "Get a value associated to PROC as property PROP
  387.          in plist stored in `url-process-lookup-table'"
  388.   (or (plist-get (cdr-safe (assq proc url-process-lookup-table)) prop)
  389.       default))
  390.  
  391. (defun url-process-put (proc prop val)
  392.   "Associate to PROC as property PROP the value VAL
  393.          in plist stored in `url-process-lookup-table'"
  394.   (let ((node (assq proc url-process-lookup-table)))
  395.     (if (not node)
  396.     (setq url-process-lookup-table (cons (cons proc (list prop val))
  397.                          url-process-lookup-table))
  398.       (setcdr node (plist-put (cdr node) prop val)))))
  399.  
  400. (defun url-gc-process-lookup-table ()
  401.   (let (new)
  402.     (while url-process-lookup-table
  403.       (if (not (memq (process-status (caar url-process-lookup-table))
  404.              '(stop closed nil)))
  405.       (setq new (cons (car url-process-lookup-table) new)))
  406.       (setq url-process-lookup-table (cdr url-process-lookup-table)))
  407.     (setq url-process-lookup-table new)))
  408.  
  409. (defun url-process-list ()
  410.   (url-gc-process-lookup-table)
  411.   (let ((processes (process-list))
  412.     (retval nil))
  413.     (while processes
  414.       (if (url-process-get (car processes) 'url)
  415.       (setq retval (cons (car processes) retval)))
  416.       (setq processes (cdr processes)))
  417.     retval))
  418.     
  419. (defun url-list-processes ()
  420.   (interactive)
  421.   (let ((processes (url-process-list))
  422.     proc total-len len type url
  423.     (url-status-buf (get-buffer-create "URL Status Display")))
  424.     (set-buffer url-status-buf)
  425.     (erase-buffer)
  426.     (display-buffer url-status-buf)
  427.     (insert
  428.      (eval-when-compile (format "%-40s %-20s %-15s" "URL" "Size" "Type")) "\n"
  429.      (eval-when-compile (make-string 77 ?-)) "\n")
  430.     (while processes
  431.       (setq proc (car processes)
  432.         processes (cdr processes))
  433.       (save-excursion
  434.     (set-buffer (process-buffer proc))
  435.     (setq total-len url-current-content-length
  436.           len (max (point-max)
  437.                (if url-current-isindex
  438.                (- (point-max) url-current-isindex)
  439.              (point-max)))
  440.           type url-current-mime-type
  441.           url (url-process-get proc 'url))
  442.     (set-buffer url-status-buf)
  443.     (insert
  444.      (format "%-40s%s%-20s %-15s\n"
  445.          (url-process-get proc 'url)
  446.          (if (> (length url) 40)
  447.              (format "\n%-40s " " ")
  448.            " ")
  449.          (if total-len
  450.              (format "%d of %d" len total-len)
  451.            (format "%d" len))
  452.          (or type "unknown")))))))
  453.  
  454.  
  455. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  456. ;;; file-name-handler stuff calls this
  457. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  458.  
  459. (defun url-have-visited-url (url &rest args)
  460.   "Return non-nil iff the user has visited URL before.
  461. The return value is a cons of the url and the date last accessed as a string"
  462.   (cl-gethash url url-global-history-hash-table))
  463.  
  464. (defun url-directory-files (url &rest args)
  465.   "Return a list of files on a server."
  466.   nil)
  467.  
  468. (defun url-file-writable-p (url &rest args)
  469.   "Return t iff a url is writable by this user"
  470.   nil)
  471.  
  472. (defun url-copy-file (url &rest args)
  473.   "Copy a url to the specified filename."
  474.   nil)
  475.  
  476. (defun url-file-directly-accessible-p (url)
  477.   "Returns t iff the specified URL is directly accessible
  478. on your filesystem.  (nfs, local file, etc)."
  479.   (let* ((urlobj (if (vectorp url) url (url-generic-parse-url url)))
  480.      (type (url-type urlobj)))
  481.     (and (member type '("file" "ftp"))
  482.      (not (url-host urlobj)))))
  483.  
  484. ;;;###autoload
  485. (defun url-file-attributes (url &rest args)
  486.   "Return a list of attributes of URL.
  487. Value is nil if specified file cannot be opened.
  488. Otherwise, list elements are:
  489.  0. t for directory, string (name linked to) for symbolic link, or nil.
  490.  1. Number of links to file.
  491.  2. File uid.
  492.  3. File gid.
  493.  4. Last access time, as a list of two integers.
  494.   First integer has high-order 16 bits of time, second has low 16 bits.
  495.  5. Last modification time, likewise.
  496.  6. Last status change time, likewise.
  497.  7. Size in bytes. (-1, if number is out of range).
  498.  8. File modes, as a string of ten letters or dashes as in ls -l.
  499.     If URL is on an http server, this will return the content-type if possible.
  500.  9. t iff file's gid would change if file were deleted and recreated.
  501. 10. inode number.
  502. 11. Device number.
  503.  
  504. If file does not exist, returns nil."
  505.   (and url
  506.        (let* ((urlobj (url-generic-parse-url url))
  507.           (type (url-type urlobj))
  508.           (url-automatic-caching nil)
  509.           (data nil)
  510.           (exists nil))
  511.      (cond
  512.       ((equal type "http")
  513.        (cond
  514.         ((not url-be-anal-about-file-attributes)
  515.          (setq data (list
  516.              (url-file-directory-p url) ; Directory
  517.              1        ; number of links to it
  518.              0        ; UID
  519.              0        ; GID
  520.              (cons 0 0)    ; Last access time
  521.              (cons 0 0)    ; Last mod. time
  522.              (cons 0 0)    ; Last status time
  523.              -1        ; file size
  524.              (mm-extension-to-mime
  525.               (url-file-extension (url-filename urlobj)))
  526.              nil        ; gid would change
  527.              0        ; inode number
  528.              0        ; device number
  529.              )))
  530.         (t                ; HTTP/1.0, use HEAD
  531.          (let ((url-request-method "HEAD")
  532.            (url-request-data nil)
  533.            (url-working-buffer " *url-temp*"))
  534.            (save-excursion
  535.          (condition-case ()
  536.              (progn
  537.                (url-retrieve url)
  538.                (setq data (and
  539.                    (setq exists
  540.                      (cdr
  541.                       (assoc "status"
  542.                          url-current-mime-headers)))
  543.                    (>= exists 200)
  544.                    (< exists 300)
  545.                    (list
  546.                     (url-file-directory-p url) ; Directory
  547.                     1    ; links to
  548.                     0    ; UID
  549.                     0    ; GID
  550.                     (cons 0 0) ; Last access time
  551.                     (cons 0 0) ; Last mod. time
  552.                     (cons 0 0) ; Last status time
  553.                     (or ; Size in bytes
  554.                      (cdr (assoc "content-length"
  555.                          url-current-mime-headers))
  556.                      -1)
  557.                     (or
  558.                      (cdr (assoc "content-type"
  559.                          url-current-mime-headers))
  560.                      (mm-extension-to-mime
  561.                       (url-file-extension
  562.                        (url-filename urlobj)))) ; content-type
  563.                     nil ; gid would change
  564.                     0    ; inode number
  565.                     0    ; device number
  566.                     ))))
  567.            (error nil))
  568.          (and (not data)
  569.               (setq data (list (url-file-directory-p url)
  570.                        1 0 0 (cons 0 0) (cons 0 0) (cons 0 0)
  571.                        -1 (mm-extension-to-mime
  572.                        (url-file-extension
  573.                         (url-filename
  574.                          url-current-object)))
  575.                        nil 0 0)))
  576.          (kill-buffer " *url-temp*"))))))
  577.       ((member type '("ftp" "file"))
  578.        (let ((fname (if (url-host urlobj)
  579.                 (concat "/"
  580.                     (if (url-user urlobj)
  581.                     (concat (url-user urlobj) "@")
  582.                       "")
  583.                     (url-host urlobj) ":"
  584.                     (url-filename urlobj))
  585.               (url-filename urlobj))))
  586.          (setq data (or (file-attributes fname) (make-list 12 nil)))
  587.          (setcar (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr data))))))))
  588.              (mm-extension-to-mime (url-file-extension fname)))))
  589.       (t nil))
  590.      data)))
  591.  
  592. (defun url-file-name-all-completions (file dirname &rest args)
  593.   "Return a list of all completions of file name FILE in directory DIR.
  594. These are all file names in directory DIR which begin with FILE."
  595.   ;; need to rewrite
  596.   )
  597.  
  598. (defun url-file-name-completion (file dirname &rest args)
  599.   "Complete file name FILE in directory DIR.
  600. Returns the longest string
  601. common to all filenames in DIR that start with FILE.
  602. If there is only one and FILE matches it exactly, returns t.
  603. Returns nil if DIR contains no name starting with FILE."
  604.   (apply 'url-file-name-all-completions file dirname args))
  605.  
  606. (defun url-file-local-copy (file &rest args)
  607.   "Copy the file FILE into a temporary file on this machine.
  608. Returns the name of the local copy, or nil, if FILE is directly
  609. accessible."
  610.   nil)
  611.  
  612. (defun url-insert-file-contents (url &rest args)
  613.   "Insert the contents of the URL in this buffer."
  614.   (interactive "sURL: ")
  615.   (save-excursion
  616.     (let ((old-asynch (default-value 'url-be-asynchronous)))
  617.       (unwind-protect
  618.       (progn
  619.         (setq-default url-be-asynchronous nil)
  620.         (let ((buf (current-buffer))
  621.           (url-working-buffer (cdr (url-retrieve url))))
  622.           (set-buffer url-working-buffer)
  623.           (url-uncompress)
  624.           (set-buffer buf)
  625.           (insert-buffer url-working-buffer)
  626.           (setq buffer-file-name url)
  627.           (save-excursion
  628.         (set-buffer url-working-buffer)
  629.         (set-buffer-modified-p nil))
  630.           (kill-buffer url-working-buffer)))
  631.     (setq-default url-be-asynchronous old-asynch)))))
  632.  
  633. (defun url-file-directory-p (url &rest args)
  634.   "Return t iff a url points to a directory"
  635.   (equal (substring url -1 nil) "/"))
  636.  
  637. (defun url-file-exists (url &rest args)
  638.   "Return t iff a file exists."
  639.   (let* ((urlobj (url-generic-parse-url url))
  640.      (type (url-type urlobj))
  641.      (exists nil))
  642.     (cond
  643.      ((equal type "http")        ; use head
  644.       (let ((url-request-method "HEAD")
  645.         (url-request-data nil)
  646.         (url-working-buffer " *url-temp*"))
  647.     (save-excursion
  648.       (url-retrieve url)
  649.       (setq exists (or (cdr
  650.                 (assoc "status" url-current-mime-headers)) 500))
  651.       (kill-buffer " *url-temp*")
  652.       (setq exists (and (>= exists 200) (< exists 300))))))
  653.      ((member type '("ftp" "file"))    ; file-attributes
  654.       (let ((fname (if (url-host urlobj)
  655.                (concat "/"
  656.                    (if (url-user urlobj)
  657.                    (concat (url-user urlobj) "@")
  658.                  "")
  659.                    (url-host urlobj) ":"
  660.                    (url-filename urlobj))
  661.              (url-filename urlobj))))
  662.     (setq exists (file-exists-p fname))))
  663.      (t nil))
  664.     exists))
  665.  
  666. ;;;###autoload
  667. (defun url-normalize-url (url)
  668.   "Return a 'normalized' version of URL.  This strips out default port
  669. numbers, etc."
  670.   (let (type data grok retval)
  671.     (setq data (url-generic-parse-url url)
  672.       type (url-type data))
  673.     (if (member type '("www" "about" "mailto" "mailserver" "info"))
  674.     (setq retval url)
  675.       (url-set-target data nil)
  676.       (setq retval (url-recreate-url data)))
  677.     retval))
  678.  
  679. ;;;###autoload
  680. (defun url-buffer-visiting (url)
  681.   "Return the name of a buffer (if any) that is visiting URL."
  682.   (setq url (url-normalize-url url))
  683.   (let ((bufs (buffer-list))
  684.     (found nil))
  685.     (while (and bufs (not found))
  686.       (save-excursion
  687.     (set-buffer (car bufs))
  688.     (setq found (if (and
  689.              (not (string-match " \\*URL-?[0-9]*\\*" (buffer-name (car bufs))))
  690.              (memq major-mode '(url-mode w3-mode))
  691.              (equal (url-normalize-url (url-view-url t)) url))
  692.             (car bufs) nil)
  693.           bufs (cdr bufs))))
  694.     found))
  695.  
  696. (defun url-file-size (url &rest args)
  697.   "Return the size of a file in bytes, or -1 if can't be determined."
  698.   (let* ((urlobj (url-generic-parse-url url))
  699.      (type (url-type urlobj))
  700.      (size -1)
  701.      (data nil))
  702.     (cond
  703.      ((equal type "http")        ; use head
  704.       (let ((url-request-method "HEAD")
  705.         (url-request-data nil)
  706.         (url-working-buffer " *url-temp*"))
  707.     (save-excursion
  708.       (url-retrieve url)
  709.       (setq size (or (cdr
  710.               (assoc "content-length" url-current-mime-headers))
  711.              -1))
  712.       (kill-buffer " *url-temp*"))))
  713.      ((member type '("ftp" "file"))    ; file-attributes
  714.       (let ((fname (if (url-host urlobj)
  715.                (concat "/"
  716.                    (if (url-user urlobj)
  717.                    (concat (url-user urlobj) "@")
  718.                  "")
  719.                    (url-host urlobj) ":"
  720.                    (url-filename urlobj))
  721.              (url-filename urlobj))))
  722.     (setq data (file-attributes fname)
  723.           size (nth 7 data))))
  724.      (t nil))
  725.     (cond
  726.      ((stringp size) (string-to-int size))
  727.      ((integerp size) size)
  728.      ((null size) -1)
  729.      (t -1))))
  730.  
  731. (defun url-generate-new-buffer-name (start)
  732.   "Create a new buffer name based on START."
  733.   (let ((x 1)
  734.     name)
  735.     (if (not (get-buffer start))
  736.     start
  737.       (progn
  738.     (setq name (format "%s<%d>" start x))
  739.     (while (get-buffer name)
  740.       (setq x (1+ x)
  741.         name (format "%s<%d>" start x)))
  742.     name))))
  743.  
  744. (defun url-generate-unique-filename (&optional fmt)
  745.   "Generate a unique filename in url-temporary-directory"
  746.   (if (not fmt)
  747.       (let ((base (format "url-tmp.%d" (user-real-uid)))
  748.         (fname "")
  749.         (x 0))
  750.     (setq fname (format "%s%d" base x))
  751.     (while (file-exists-p (expand-file-name fname url-temporary-directory))
  752.       (setq x (1+ x)
  753.         fname (concat base (int-to-string x))))
  754.     (expand-file-name fname url-temporary-directory))
  755.     (let ((base (concat "url" (int-to-string (user-real-uid))))
  756.       (fname "")
  757.       (x 0))
  758.       (setq fname (format fmt (concat base (int-to-string x))))
  759.       (while (file-exists-p (expand-file-name fname url-temporary-directory))
  760.     (setq x (1+ x)
  761.           fname (format fmt (concat base (int-to-string x)))))
  762.       (expand-file-name fname url-temporary-directory))))
  763.  
  764. (defun url-lazy-message (&rest args)
  765.   "Just like `message', but is a no-op if called more than once a second.
  766. Will not do anything if url-show-status is nil."
  767.   (if (or (null url-show-status)
  768.       (active-minibuffer-window)
  769.       (= url-lazy-message-time
  770.          (setq url-lazy-message-time (nth 1 (current-time)))))
  771.       nil
  772.     (apply 'message args)))
  773.  
  774.  
  775. (defun url-kill-process (proc)
  776.   "Kill the process PROC - knows about all the various gateway types,
  777. and acts accordingly."
  778.   (delete-process proc))
  779.  
  780. (defun url-accept-process-output (proc)
  781.   "Allow any pending output from subprocesses to be read by Emacs.
  782. It is read into the process' buffers or given to their filter functions.
  783. Where possible, this will not exit until some output is received from PROC,
  784. or 1 second has elapsed."
  785.   (accept-process-output proc 1))
  786.  
  787. (defun url-process-status (proc)
  788.   "Return the process status of a url buffer"
  789.   (process-status proc))
  790.  
  791.  
  792. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  793. ;;; Miscellaneous functions
  794. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  795. (defun url-setup-privacy-info ()
  796.   (interactive)
  797.   (setq url-system-type
  798.     (cond
  799.      ((or (eq url-privacy-level 'paranoid)
  800.           (and (listp url-privacy-level)
  801.            (memq 'os url-privacy-level)))
  802.       nil)
  803.      ;; First, we handle the inseparable OS/Windowing system
  804.      ;; combinations
  805.      ((eq system-type 'Apple-Macintosh) "Macintosh")
  806.      ((eq system-type 'next-mach) "NeXT")
  807.      ((eq system-type 'windows-nt) "Windows-NT; 32bit")
  808.      ((eq system-type 'ms-windows) "Windows; 16bit")
  809.      ((eq system-type 'ms-dos) "MS-DOS; 32bit")
  810.      ((memq (device-type) '(win32 w32)) "Windows; 32bit")
  811.      ((eq (device-type) 'pm) "OS/2; 32bit")
  812.      (t
  813.       (case (device-type)
  814.         (x "X11")
  815.         (ns "OpenStep")
  816.         (tty "TTY")
  817.         (otherwise nil)))))
  818.  
  819.   (setq url-personal-mail-address (or url-personal-mail-address
  820.                       user-mail-address
  821.                       (format "%s@%s"  (user-real-login-name)
  822.                           (system-name))))
  823.  
  824.   (if (or (memq url-privacy-level '(paranoid high))
  825.       (and (listp url-privacy-level)
  826.            (memq 'email url-privacy-level)))
  827.       (setq url-personal-mail-address nil))
  828.  
  829.   (setq url-os-type
  830.     (cond
  831.      ((or (eq url-privacy-level 'paranoid)
  832.           (and (listp url-privacy-level)
  833.            (memq 'os url-privacy-level)))
  834.       nil)
  835.      ((boundp 'system-configuration)
  836.       system-configuration)
  837.      ((boundp 'system-type)
  838.       (symbol-name system-type))
  839.      (t nil))))
  840.  
  841. (defun url-handle-no-scheme (url)
  842.   (let ((temp url-registered-protocols)
  843.     (found nil))
  844.     (while (and temp (not found))
  845.       (if (and (not (member (car (car temp)) '("auto" "www")))
  846.            (string-match (concat "^" (car (car temp)) "\\.")
  847.                     url))
  848.       (setq found t)
  849.     (setq temp (cdr temp))))
  850.     (cond
  851.      (found                ; Found something like ftp.spry.com
  852.       (url-retrieve (concat (car (car temp)) "://" url)))
  853.      ((string-match "^www\\." url)
  854.       (url-retrieve (concat "http://" url)))
  855.      ((string-match "\\(\\.[^\\.]+\\)\\(\\.[^\\.]+\\)" url)
  856.       ;; Ok, we have at least two dots in the filename, just stick http on it
  857.       (url-retrieve (concat "http://" url)))
  858.      ((setq temp (run-hook-with-args-until-success
  859.           'url-handle-no-scheme-hook url))
  860.       (url-retrieve temp))
  861.      (t
  862.       (url-retrieve (concat "http://www." url ".com"))))))
  863.  
  864. ;;;###autoload
  865. (defun url-setup-save-timer ()
  866.   "Reset the history list timer."
  867.   (interactive)
  868.   (cond
  869.    ((featurep 'itimer)
  870.     (if (get-itimer "url-history-saver")
  871.     (delete-itimer (get-itimer "url-history-saver")))
  872.     (start-itimer "url-history-saver" 'url-write-global-history
  873.           url-global-history-save-interval
  874.           url-global-history-save-interval))
  875.    ((fboundp 'run-at-time)
  876.     (run-at-time url-global-history-save-interval
  877.          url-global-history-save-interval
  878.          'url-write-global-history))
  879.    (t nil)))
  880.  
  881. (defvar url-download-minor-mode nil)
  882.  
  883. (defun url-download-minor-mode (on)
  884.   (setq url-download-minor-mode (if on
  885.                    (1+ (or url-download-minor-mode 0))
  886.                  (1- (or url-download-minor-mode 1))))
  887.   (if (<= url-download-minor-mode 0)
  888.       (setq url-download-minor-mode nil)))
  889.  
  890. ;;;###autoload
  891. (defun url-do-setup ()
  892.   "Do setup - this is to avoid conflict with user settings when URL is
  893. dumped with emacs."
  894.   (if url-setup-done
  895.       nil
  896.  
  897.     (add-minor-mode 'url-download-minor-mode " Webbing" nil)
  898.     
  899.     ;; Make OS/2 happy
  900.     (setq tcp-binary-process-input-services
  901.       (append '("http" "80")
  902.           tcp-binary-process-input-services))
  903.     
  904.     ;; Register all the protocols we can handle
  905.     (url-register-protocol 'file)
  906.     (url-register-protocol 'ftp        nil nil "21")
  907.     (url-register-protocol 'gopher     nil nil "70")
  908.     (url-register-protocol 'http       nil nil "80")
  909.     (url-register-protocol 'https      nil nil "443")
  910.     (url-register-protocol 'nfs        nil nil "2049")
  911.     (url-register-protocol 'info       nil 'url-identity-expander)
  912.     (url-register-protocol 'mailserver nil 'url-identity-expander)
  913.     (url-register-protocol 'finger     nil 'url-identity-expander "79")
  914.     (url-register-protocol 'mailto     nil 'url-identity-expander)
  915.     (url-register-protocol 'news       nil 'url-identity-expander "119")
  916.     (url-register-protocol 'nntp       nil 'url-identity-expander "119")
  917.     (url-register-protocol 'irc        nil 'url-identity-expander "6667")
  918.     (url-register-protocol 'data       nil 'url-identity-expander)
  919.     (url-register-protocol 'netrek     nil 'url-identity-expander)
  920.     (url-register-protocol 'rlogin)
  921.     (url-register-protocol 'telnet)
  922.     (url-register-protocol 'tn3270)
  923.     (url-register-protocol 'proxy)
  924.     (url-register-protocol 'auto 'url-handle-no-scheme)
  925.  
  926.     ;; Register all the authentication schemes we can handle
  927.     (url-register-auth-scheme "basic" nil 4)
  928.     (url-register-auth-scheme "digest" nil 7)
  929.  
  930.     ;; Filename handler stuff for emacsen that support it
  931.     (url-setup-file-name-handlers)
  932.  
  933.     (setq url-cookie-file
  934.       (or url-cookie-file
  935.           (expand-file-name "~/.w3/cookies")))
  936.     
  937.     (setq url-global-history-file
  938.       (or url-global-history-file
  939.           (and (memq system-type '(ms-dos ms-windows))
  940.            (expand-file-name "~/mosaic.hst"))
  941.           (and (memq system-type '(axp-vms vax-vms))
  942.            (expand-file-name "~/mosaic.global-history"))
  943.           (condition-case ()
  944.           (expand-file-name "~/.w3/history")
  945.         (error nil))))
  946.   
  947.     ;; Parse the global history file if it exists, so that it can be used
  948.     ;; for URL completion, etc.
  949.     (if (and url-global-history-file
  950.          (file-exists-p url-global-history-file))
  951.     (url-parse-global-history))
  952.  
  953.     ;; Setup save timer
  954.     (and url-global-history-save-interval (url-setup-save-timer))
  955.  
  956.     (if (and url-cookie-file
  957.          (file-exists-p url-cookie-file))
  958.     (url-cookie-parse-file url-cookie-file))
  959.     
  960.     ;; Read in proxy gateways
  961.     (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
  962.             (or (getenv "NO_PROXY")
  963.                 (getenv "no_PROXY")
  964.                 (getenv "no_proxy")))))
  965.       (if noproxy
  966.       (setq url-proxy-services
  967.         (cons (cons "no_proxy"
  968.                 (concat "\\("
  969.                     (mapconcat
  970.                      (function
  971.                       (lambda (x)
  972.                     (cond
  973.                      ((= x ?,) "\\|")
  974.                      ((= x ? ) "")
  975.                      ((= x ?.) (regexp-quote "."))
  976.                      ((= x ?*) ".*")
  977.                      ((= x ??) ".")
  978.                      (t (char-to-string x)))))
  979.                      noproxy "") "\\)"))
  980.               url-proxy-services))))
  981.  
  982.     ;; Set the password entry funtion based on user defaults or guess
  983.     ;; based on which remote-file-access package they are using.
  984.     (cond
  985.      (url-passwd-entry-func nil)    ; Already been set
  986.      ((fboundp 'read-passwd)        ; Use secure password if available
  987.       (setq url-passwd-entry-func 'read-passwd))
  988.      ((or (featurep 'efs)        ; Using EFS
  989.       (featurep 'efs-auto))        ; or autoloading efs
  990.       (if (not (fboundp 'read-passwd))
  991.       (autoload 'read-passwd "passwd" "Read in a password" nil))
  992.       (setq url-passwd-entry-func 'read-passwd))
  993.      ((or (featurep 'ange-ftp)        ; Using ange-ftp
  994.       (and (boundp 'file-name-handler-alist)
  995.            (not (string-match "Lucid" (emacs-version)))))
  996.       (setq url-passwd-entry-func 'ange-ftp-read-passwd))
  997.      (t
  998.       (url-warn
  999.        'security
  1000.        "(url-setup): Can't determine how to read passwords, winging it.")))
  1001.   
  1002.     ;; Set up the news service if they haven't done so
  1003.     (setq url-news-server
  1004.       (cond
  1005.        (url-news-server url-news-server)
  1006.        ((and (boundp 'gnus-default-nntp-server)
  1007.          (not (equal "" gnus-default-nntp-server)))
  1008.         gnus-default-nntp-server)
  1009.        ((and (boundp 'gnus-nntp-server)
  1010.          (not (null gnus-nntp-server))
  1011.          (not (equal "" gnus-nntp-server)))
  1012.         gnus-nntp-server)
  1013.        ((and (boundp 'nntp-server-name)
  1014.          (not (null nntp-server-name))
  1015.          (not (equal "" nntp-server-name)))
  1016.         nntp-server-name)
  1017.        ((getenv "NNTPSERVER") (getenv "NNTPSERVER"))
  1018.        (t "news")))
  1019.   
  1020.     ;; Set up the MIME accept string if they haven't got it hardcoded yet
  1021.     (or url-mime-accept-string
  1022.     (setq url-mime-accept-string (url-parse-viewer-types)))
  1023.     (or url-mime-encoding-string
  1024.     (setq url-mime-encoding-string
  1025.           (mapconcat 'car
  1026.              mm-content-transfer-encodings
  1027.              ", ")))
  1028.   
  1029.     (url-setup-privacy-info)
  1030.     (run-hooks 'url-load-hook)
  1031.     (setq url-setup-done t)))
  1032.  
  1033. (defvar url-get-url-filename-chars "-%.?@a-zA-Z0-9()_/:~=&"
  1034.   "Valid characters in a URL")
  1035.  
  1036. ;;;###autoload
  1037. (defun url-get-url-at-point (&optional pt)
  1038.   "Get the URL closest to point, but don't change your
  1039. position. Has a preference for looking backward when not
  1040. directly on a symbol."
  1041.   ;; Not at all perfect - point must be right in the name.
  1042.   (save-excursion
  1043.     (if pt (goto-char pt))
  1044.     (let (start url)
  1045.       (save-excursion
  1046.     ;; first see if you're just past a filename
  1047.     (if (not (eobp))
  1048.         (if (looking-at "[] \t\n[{}()]") ; whitespace or some parens
  1049.         (progn
  1050.           (skip-chars-backward " \n\t\r({[]})")
  1051.           (if (not (bobp))
  1052.               (backward-char 1)))))
  1053.     (if (and (char-after (point))
  1054.          (string-match (eval-when-compile
  1055.                  (concat "[" url-get-url-filename-chars "]"))
  1056.                    (char-to-string (char-after (point)))))
  1057.         (progn
  1058.           (skip-chars-backward url-get-url-filename-chars)
  1059.           (setq start (point))
  1060.           (skip-chars-forward url-get-url-filename-chars))
  1061.       (setq start (point)))
  1062.     (setq url (buffer-substring-no-properties start (point))))
  1063.       (if (string-match "^(.*)$" url)
  1064.       (setq url (substring url 1 -1)))
  1065.       (if (string-match "^URL:" url)
  1066.       (setq url (substring url 4 nil)))
  1067.       (if (string-match "\\.$" url)
  1068.       (setq url (substring url 0 -1)))
  1069.       (if (string-match "^www\\." url)
  1070.       (setq url (concat "http://" url)))
  1071.       (if (not (string-match url-nonrelative-link url))
  1072.       (setq url nil))
  1073.       url)))
  1074.  
  1075. (defun url-eat-trailing-space (x)
  1076.   ;; Remove spaces/tabs at the end of a string
  1077.   (let ((y (1- (length x)))
  1078.     (skip-chars (list ?  ?\t ?\n)))
  1079.     (while (and (>= y 0) (memq (aref x y) skip-chars))
  1080.       (setq y (1- y)))
  1081.     (substring x 0 (1+ y))))
  1082.  
  1083. (defun url-strip-leading-spaces (x)
  1084.   ;; Remove spaces at the front of a string
  1085.   (let ((y (1- (length x)))
  1086.     (z 0)
  1087.     (skip-chars (list ?  ?\t ?\n)))
  1088.     (while (and (<= z y) (memq (aref x z) skip-chars))
  1089.       (setq z (1+ z)))
  1090.     (substring x z nil)))
  1091.  
  1092. (defun url-convert-newlines-to-spaces (x)
  1093.   "Convert newlines and carriage returns embedded in a string into spaces,
  1094. and swallow following whitespace.
  1095. The argument is not side-effected, but may be returned by this function."
  1096.   (if (string-match "[\n\r]+\\s-*" x)   ; [\\n\\r\\t ]
  1097.       (concat (substring x 0 (match-beginning 0)) " "
  1098.           (url-convert-newlines-to-spaces
  1099.            (substring x (match-end 0))))
  1100.     x))
  1101.  
  1102. ;; Test cases
  1103. ;; (url-convert-newlines-to-spaces "foo    bar")  ; nothing happens
  1104. ;; (url-convert-newlines-to-spaces "foo\n  \t  bar") ; whitespace converted
  1105. ;;
  1106. ;; This implementation doesn't mangle the match-data, is fast, and doesn't
  1107. ;; create garbage, but it leaves whitespace.
  1108. ;; (defun url-convert-newlines-to-spaces (x)
  1109. ;;   "Convert newlines and carriage returns embedded in a string into spaces.
  1110. ;; The string is side-effected, then returned."
  1111. ;;   (let ((i 0)
  1112. ;;      (limit (length x)))
  1113. ;;     (while (< i limit)
  1114. ;;       (if (or (= ?\n (aref x i))
  1115. ;;            (= ?\r (aref x i)))
  1116. ;;        (aset x i ? ))
  1117. ;;       (setq i (1+ i)))
  1118. ;;     x))
  1119.  
  1120. (defun url-expand-file-name (url &optional default)
  1121.   "Convert URL to a fully specified URL, and canonicalize it.
  1122. Second arg DEFAULT is a URL to start with if URL is relative.
  1123. If DEFAULT is nil or missing, the current buffer's URL is used.
  1124. Path components that are `.' are removed, and 
  1125. path components followed by `..' are removed, along with the `..' itself."
  1126.   (if url
  1127.       (setq url (mapconcat (function (lambda (x)
  1128.                        (if (memq x '(?  ?\n ?\r))
  1129.                        ""
  1130.                      (char-to-string x))))
  1131.                (url-strip-leading-spaces
  1132.                 (url-eat-trailing-space url)) "")))
  1133.   (cond
  1134.    ((null url) nil)            ; Something hosed!  Be graceful
  1135.    ((string-match "^#" url)        ; Offset link, use it raw
  1136.     url)
  1137.    (t
  1138.     (let* ((urlobj (url-generic-parse-url url))
  1139.        (inhibit-file-name-handlers t)
  1140.        (defobj (cond
  1141.             ((vectorp default) default)
  1142.             (default (url-generic-parse-url default))
  1143.             (url-current-object url-current-object)
  1144.             (t (url-generic-parse-url (url-view-url t)))))
  1145.        (expander (cdr-safe
  1146.               (cdr-safe
  1147.                (assoc (or (url-type urlobj)
  1148.                   (url-type defobj))
  1149.                   url-registered-protocols)))))
  1150.       (if (string-match "^//" url)
  1151.       (setq urlobj (url-generic-parse-url (concat (url-type defobj) ":"
  1152.                               url))))
  1153.       (if (fboundp expander)
  1154.       (funcall expander urlobj defobj)
  1155.     (message "Unknown URL scheme: %s" (or (url-type urlobj)
  1156.                          (url-type defobj)))
  1157.     (url-identity-expander urlobj defobj))
  1158.       (url-recreate-url urlobj)))))
  1159.  
  1160. (defun url-default-expander (urlobj defobj)
  1161.   ;; The default expansion routine - urlobj is modified by side effect!
  1162.   (url-set-type urlobj (or (url-type urlobj) (url-type defobj)))
  1163.   (url-set-port urlobj (or (url-port urlobj)
  1164.                (and (string= (url-type urlobj)
  1165.                      (url-type defobj))
  1166.                 (url-port defobj))))
  1167.   (if (not (string= "file" (url-type urlobj)))
  1168.       (url-set-host urlobj (or (url-host urlobj) (url-host defobj))))
  1169.   (if (string= "ftp"  (url-type urlobj))
  1170.       (url-set-user urlobj (or (url-user urlobj) (url-user defobj))))
  1171.   (if (string= (url-filename urlobj) "")
  1172.       (url-set-filename urlobj "/"))
  1173.   (if (string-match "^/" (url-filename urlobj))
  1174.       nil
  1175.     (url-set-filename urlobj
  1176.               (url-remove-relative-links
  1177.                (concat (url-basepath (url-filename defobj))
  1178.                    (url-filename urlobj))))))
  1179.  
  1180. (defun url-identity-expander (urlobj defobj)
  1181.   (url-set-type urlobj (or (url-type urlobj) (url-type defobj))))
  1182.  
  1183. (defconst url-unreserved-chars
  1184.   '(
  1185.     ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
  1186.     ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
  1187.     ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
  1188.     ?$ ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\) ?,)
  1189.   "A list of characters that are _NOT_ reserve in the URL spec.
  1190. This is taken from draft-fielding-url-syntax-02.txt - check your local
  1191. internet drafts directory for a copy.")
  1192.        
  1193. (defun url-hexify-string (str)
  1194.   "Escape characters in a string"
  1195.   (mapconcat
  1196.    (function
  1197.     (lambda (char)
  1198.       (if (not (memq char url-unreserved-chars))
  1199.       (if (< char 16)
  1200.           (upcase (format "%%0%x" char))
  1201.         (upcase (format "%%%x" char)))
  1202.     (char-to-string char))))
  1203.    (mule-decode-string str) ""))
  1204.  
  1205. (defun url-make-sequence (start end)
  1206.   "Make a sequence (list) of numbers from START to END"
  1207.   (cond
  1208.    ((= start end) '())
  1209.    ((> start end) '())
  1210.    (t
  1211.     (let ((sqnc '()))
  1212.       (while (<= start end)
  1213.     (setq sqnc (cons end sqnc)
  1214.           end (1- end)))
  1215.       sqnc))))
  1216.  
  1217. (defun url-file-extension (fname &optional x)
  1218.   "Return the filename extension of FNAME.  If optional variable X is t,
  1219. then return the basename of the file with the extension stripped off."
  1220.   (if (and fname (string-match "\\.[^./]+$" fname))
  1221.       (if x (substring fname 0 (match-beginning 0))
  1222.     (substring fname (match-beginning 0) nil))
  1223.     ;;
  1224.     ;; If fname has no extension, and x then return fname itself instead of 
  1225.     ;; nothing. When caching it allows the correct .hdr file to be produced
  1226.     ;; for filenames without extension.
  1227.     ;;
  1228.     (if x
  1229.      fname
  1230.       "")))
  1231.  
  1232. (defun url-basepath (file &optional x)
  1233.   "Return the base pathname of FILE, or the actual filename if X is true"
  1234.   (cond
  1235.    ((null file) "")
  1236.    (x (file-name-nondirectory file))
  1237.    (t (file-name-directory file))))
  1238.  
  1239. (defun url-parse-query-string (query &optional downcase)
  1240.   (let (retval pairs cur key val)
  1241.     (setq pairs (split-string query "&"))
  1242.     (while pairs
  1243.       (setq cur (car pairs)
  1244.         pairs (cdr pairs))
  1245.       (if (not (string-match "=" cur))
  1246.       nil                ; Grace
  1247.     (setq key (url-unhex-string (substring cur 0 (match-beginning 0)))
  1248.           val (url-unhex-string (substring cur (match-end 0) nil)))
  1249.     (if downcase
  1250.         (setq key (downcase key)))
  1251.     (setq cur (assoc key retval))
  1252.     (if cur
  1253.         (setcdr cur (cons val (cdr cur)))
  1254.       (setq retval (cons (list key val) retval)))))
  1255.     retval))
  1256.  
  1257. (defun url-unhex (x)
  1258.   (if (> x ?9)
  1259.       (if (>= x ?a)
  1260.       (+ 10 (- x ?a))
  1261.     (+ 10 (- x ?A)))
  1262.     (- x ?0)))
  1263.  
  1264. (defun url-unhex-string (str &optional allow-newlines)
  1265.   "Remove %XXX embedded spaces, etc in a url.
  1266. If optional second argument ALLOW-NEWLINES is non-nil, then allow the
  1267. decoding of carriage returns and line feeds in the string, which is normally
  1268. forbidden in URL encoding."
  1269.   (setq str (or str ""))
  1270.   (let ((tmp "")
  1271.     (case-fold-search t))
  1272.     (while (string-match "%[0-9a-f][0-9a-f]" str)
  1273.       (let* ((start (match-beginning 0))
  1274.          (ch1 (url-unhex (elt str (+ start 1))))
  1275.          (code (+ (* 16 ch1)
  1276.               (url-unhex (elt str (+ start 2))))))
  1277.     (setq tmp (concat 
  1278.            tmp (substring str 0 start)
  1279.            (cond
  1280.             (allow-newlines
  1281.              (char-to-string code))
  1282.             ((or (= code ?\n) (= code ?\r))
  1283.              " ")
  1284.             (t (char-to-string code))))
  1285.           str (substring str (match-end 0)))))
  1286.     (setq tmp (concat tmp str))
  1287.     tmp))
  1288.  
  1289. (defun url-remove-compressed-extensions (filename)
  1290.   (while (assoc (url-file-extension filename) url-uncompressor-alist)
  1291.     (setq filename (url-file-extension filename t)))
  1292.   filename)
  1293.  
  1294. (defun url-uncompress ()
  1295.   "Do any necessary uncompression on `url-working-buffer'"
  1296.   (set-buffer url-working-buffer)
  1297.   (if (not url-inhibit-uncompression)
  1298.       (let* ((decoder nil)
  1299.          (code-1 (cdr-safe
  1300.               (assoc "content-transfer-encoding"
  1301.                  url-current-mime-headers)))
  1302.          (code-2 (cdr-safe
  1303.               (assoc "content-encoding" url-current-mime-headers)))
  1304.          (done nil)
  1305.          (default-process-coding-system
  1306.            (cons mule-no-coding-system mule-no-coding-system)))
  1307.     (mapcar
  1308.      (function
  1309.       (lambda (code)
  1310.         (setq decoder (and (not (member code done))
  1311.                    (cdr-safe
  1312.                 (assoc code mm-content-transfer-encodings)))
  1313.           done (cons code done))
  1314.         (if (not decoder)
  1315.         nil
  1316.           (message "Decoding (%s)..." code)
  1317.           (cond
  1318.            ((stringp decoder)
  1319.         (call-process-region (point-min) (point-max) decoder t t nil))
  1320.            ((listp decoder)
  1321.         (apply 'call-process-region (point-min) (point-max)
  1322.                (car decoder) t t nil (cdr decoder)))
  1323.            ((and (symbolp decoder) (fboundp decoder))
  1324.         (funcall decoder (point-min) (point-max)))
  1325.            (t
  1326.         (error "Bad entry for %s in `mm-content-transfer-encodings'"
  1327.                code)))
  1328.           (message "Decoding (%s)... done." code))))
  1329.      (list code-1 code-2))))
  1330.   (set-buffer-modified-p nil))
  1331.  
  1332. (defun url-filter (proc string)
  1333.   (save-excursion
  1334.     (set-buffer url-working-buffer)
  1335.     (insert string)
  1336.     (if (string-match "\nConnection closed by" string)
  1337.     (progn (set-process-filter proc nil)
  1338.            (url-sentinel proc string))))
  1339.   string)
  1340.  
  1341. (defun url-default-callback (buf)
  1342.   (url-download-minor-mode nil)
  1343.   (url-store-in-cache buf)
  1344.   (cond
  1345.    ((save-excursion (set-buffer buf)
  1346.             (and url-current-callback-func
  1347.              (fboundp url-current-callback-func)))
  1348.     (save-excursion
  1349.       (save-window-excursion
  1350.     (set-buffer buf)
  1351.     (cond
  1352.      ((listp url-current-callback-data)
  1353.       (apply url-current-callback-func
  1354.          url-current-callback-data))
  1355.      (url-current-callback-data
  1356.       (funcall url-current-callback-func
  1357.            url-current-callback-data))
  1358.      (t
  1359.       (funcall url-current-callback-func))))))
  1360.    ((and (fboundp 'w3-sentinel) (get-buffer buf))
  1361.     (w3-sentinel))
  1362.    (t
  1363.     (message "Retrieval for %s complete." buf))))
  1364.  
  1365. (defun url-sentinel (proc string)
  1366.   (let* ((buf (if (processp proc) (process-buffer proc) proc))
  1367.      (url-working-buffer (and buf (get-buffer buf)))
  1368.      status)
  1369.     (if (not url-working-buffer)
  1370.     (url-warn 'url (format "Process %s completed with no buffer!" proc))
  1371.       (save-excursion
  1372.     (set-buffer url-working-buffer)
  1373.     (remove-hook 'after-change-functions 'url-after-change-function)
  1374.     (if url-be-asynchronous
  1375.         (progn
  1376.           (widen)
  1377.           (cond
  1378.            ((and (null proc) (not url-working-buffer)) nil)
  1379.            ((url-mime-response-p)
  1380.         (setq status (url-parse-mime-headers))))
  1381.           (if (not url-current-mime-type)
  1382.           (setq url-current-mime-type (or
  1383.                            (mm-extension-to-mime
  1384.                         (url-file-extension
  1385.                          (url-filename
  1386.                           url-current-object)))
  1387.                            "text/plain"))))))
  1388.       (if (member status '(401 301 302 303 204))
  1389.       nil
  1390.     (funcall url-default-retrieval-proc (buffer-name url-working-buffer)))))
  1391.   ;; FSF Emacs doesn't do this after calling a process-sentinel
  1392.   (set-buffer (window-buffer (selected-window))))
  1393.  
  1394. (defun url-remove-relative-links (name)
  1395.   ;; Strip . and .. from pathnames
  1396.   (let ((new (if (not (string-match "^/" name))
  1397.          (concat "/" name)
  1398.            name)))
  1399.     (while (string-match "/\\(\\./\\)" new)
  1400.       (setq new (concat (substring new 0 (match-beginning 1))
  1401.             (substring new (match-end 1)))))
  1402.     (while (string-match "/\\([^/]*/\\.\\./\\)" new)
  1403.       (setq new (concat (substring new 0 (match-beginning 1))
  1404.             (substring new (match-end 1)))))
  1405.     (while (string-match "^/\\.\\.\\(/\\)" new)
  1406.       (setq new (substring new (match-beginning 1) nil)))
  1407.     new))
  1408.  
  1409. (defun url-truncate-url-for-viewing (url &optional width)
  1410.   "Return a shortened version of URL that is WIDTH characters or less wide.
  1411. WIDTH defaults to the current frame width."
  1412.   (let* ((fr-width (or width (frame-width)))
  1413.      (str-width (length url))
  1414.      (tail (file-name-nondirectory url))
  1415.      (fname nil)
  1416.      (modified 0)
  1417.      (urlobj nil))
  1418.     ;; The first thing that can go are the search strings
  1419.     (if (and (>= str-width fr-width)
  1420.          (string-match "?" url))
  1421.     (setq url (concat (substring url 0 (match-beginning 0)) "?...")
  1422.           str-width (length url)
  1423.           tail (file-name-nondirectory url)))
  1424.     (if (< str-width fr-width)
  1425.     nil                ; Hey, we are done!
  1426.       (setq urlobj (url-generic-parse-url url)
  1427.         fname (url-filename urlobj)
  1428.         fr-width (- fr-width 4))
  1429.       (while (and (>= str-width fr-width)
  1430.           (string-match "/" fname))
  1431.     (setq fname (substring fname (match-end 0) nil)
  1432.           modified (1+ modified))
  1433.     (url-set-filename urlobj fname)
  1434.     (setq url (url-recreate-url urlobj)
  1435.           str-width (length url)))
  1436.       (if (> modified 1)
  1437.       (setq fname (concat "/.../" fname))
  1438.     (setq fname (concat "/" fname)))
  1439.       (url-set-filename urlobj fname)
  1440.       (setq url (url-recreate-url urlobj)))
  1441.     url))
  1442.  
  1443. (defun url-view-url (&optional no-show)
  1444.   "View the current document's URL.  Optional argument NO-SHOW means
  1445. just return the URL, don't show it in the minibuffer."
  1446.   (interactive)
  1447.   (if (not url-current-object)
  1448.       nil
  1449.     (if no-show
  1450.     (url-recreate-url url-current-object)
  1451.       (message "%s" (url-recreate-url url-current-object)))))
  1452.  
  1453. (defun url-parse-Netscape-history (fname)
  1454.   ;; Parse a Netscape/X style global history list.
  1455.   (let (pos                ; Position holder
  1456.     url                ; The URL
  1457.     time)                ; Last time accessed
  1458.     (goto-char (point-min))
  1459.     (skip-chars-forward "^\n")
  1460.     (skip-chars-forward "\n \t")    ; Skip past the tag line
  1461.     (setq url-global-history-hash-table (make-hash-table :size 131
  1462.                              :test 'equal))
  1463.     ;; Here we will go to the end of the line and
  1464.     ;; skip back over a token, since we might run
  1465.     ;; into spaces in URLs, depending on how much
  1466.     ;; smarter netscape is than the old XMosaic :)
  1467.     (while (not (eobp))
  1468.       (setq pos (point))
  1469.       (end-of-line)
  1470.       (skip-chars-backward "^ \t")
  1471.       (skip-chars-backward " \t")
  1472.       (setq url (buffer-substring pos (point))
  1473.         pos (1+ (point)))
  1474.       (skip-chars-forward "^\n")
  1475.       (setq time (buffer-substring pos (point)))
  1476.       (skip-chars-forward "\n")
  1477.       (setq url-history-changed-since-last-save t)
  1478.       (cl-puthash url time url-global-history-hash-table))))
  1479.  
  1480. (defun url-parse-Mosaic-history-v1 (fname)
  1481.   ;; Parse an NCSA Mosaic/X style global history list
  1482.   (goto-char (point-min))
  1483.   (skip-chars-forward "^\n")
  1484.   (skip-chars-forward "\n \t")    ; Skip past the tag line
  1485.   (skip-chars-forward "^\n")
  1486.   (skip-chars-forward "\n \t")    ; Skip past the second tag line
  1487.   (setq url-global-history-hash-table (make-hash-table :size 131
  1488.                                :test 'equal))
  1489.   (let (pos                ; Temporary position holder
  1490.     bol                ; Beginning-of-line
  1491.     url                ; URL
  1492.     time                ; Time
  1493.     last-end            ; Last ending point
  1494.     )
  1495.     (while (not (eobp))
  1496.       (setq bol (point))
  1497.       (end-of-line)
  1498.       (setq pos (point)
  1499.         last-end (point))
  1500.       (skip-chars-backward "^ \t" bol)    ; Skip over year
  1501.       (skip-chars-backward " \t" bol)
  1502.       (skip-chars-backward "^ \t" bol)    ; Skip over time
  1503.       (skip-chars-backward " \t" bol)
  1504.       (skip-chars-backward "^ \t" bol)    ; Skip over day #
  1505.       (skip-chars-backward " \t" bol)
  1506.       (skip-chars-backward "^ \t" bol)    ; Skip over month
  1507.       (skip-chars-backward " \t" bol)
  1508.       (skip-chars-backward "^ \t" bol)    ; Skip over day abbrev.
  1509.       (if (bolp)
  1510.       nil                ; Malformed entry!!! Ack! Bailout!
  1511.     (setq time (buffer-substring pos (point)))
  1512.     (skip-chars-backward " \t")
  1513.     (setq pos (point)))
  1514.       (beginning-of-line)
  1515.       (setq url (buffer-substring (point) pos))
  1516.       (goto-char (min (1+ last-end) (point-max))) ; Goto next line
  1517.       (if (/= (length url) 0)
  1518.       (progn
  1519.         (setq url-history-changed-since-last-save t)
  1520.         (cl-puthash url time url-global-history-hash-table))))))
  1521.  
  1522. (defun url-parse-Mosaic-history-v2 (fname)
  1523.   ;; Parse an NCSA Mosaic/X style global history list (version 2)
  1524.   (goto-char (point-min))
  1525.   (skip-chars-forward "^\n")
  1526.   (skip-chars-forward "\n \t")    ; Skip past the tag line
  1527.   (skip-chars-forward "^\n")
  1528.   (skip-chars-forward "\n \t")    ; Skip past the second tag line
  1529.   (setq url-global-history-hash-table (make-hash-table :size 131
  1530.                                :test 'equal))
  1531.   (let (pos                ; Temporary position holder
  1532.     bol                ; Beginning-of-line
  1533.     url                ; URL
  1534.     time                ; Time
  1535.     last-end            ; Last ending point
  1536.     )
  1537.     (while (not (eobp))
  1538.       (setq bol (point))
  1539.       (end-of-line)
  1540.       (setq pos (point)
  1541.         last-end (point))
  1542.       (skip-chars-backward "^ \t" bol)    ; Skip over time
  1543.       (if (bolp)
  1544.       nil                ; Malformed entry!!! Ack! Bailout!
  1545.     (setq time (buffer-substring pos (point)))
  1546.     (skip-chars-backward " \t")
  1547.     (setq pos (point)))
  1548.       (beginning-of-line)
  1549.       (setq url (buffer-substring (point) pos))
  1550.       (goto-char (min (1+ last-end) (point-max))) ; Goto next line
  1551.       (if (/= (length url) 0)
  1552.       (progn
  1553.         (setq url-history-changed-since-last-save t)
  1554.         (cl-puthash url time url-global-history-hash-table))))))
  1555.  
  1556. (defun url-parse-Emacs-history (&optional fname)
  1557.   ;; Parse out the Emacs-w3 global history file for completion, etc.
  1558.   (or fname (setq fname (expand-file-name url-global-history-file)))
  1559.   (cond
  1560.    ((not (file-exists-p fname))
  1561.     (message "%s does not exist." fname))
  1562.    ((not (file-readable-p fname))
  1563.     (message "%s is unreadable." fname))
  1564.    (t
  1565.     (condition-case ()
  1566.     (load fname nil t)
  1567.       (error (message "Could not load %s" fname)))
  1568.     (if (boundp 'url-global-history-completion-list)
  1569.     ;; Hey!  Automatic conversion of old format!
  1570.     (progn
  1571.       (setq url-global-history-hash-table (make-hash-table :size 131
  1572.                                    :test 'equal)
  1573.         url-history-changed-since-last-save t)
  1574.       (mapcar (function
  1575.            (lambda (x)
  1576.              (cl-puthash (car x) (cdr x)
  1577.                  url-global-history-hash-table)))
  1578.           (symbol-value 'url-global-history-completion-list)))))))
  1579.  
  1580. (defun url-parse-global-history (&optional fname)
  1581.   ;; Parse out the mosaic global history file for completions, etc.
  1582.   (or fname (setq fname (expand-file-name url-global-history-file)))
  1583.   (cond
  1584.    ((not (file-exists-p fname))
  1585.     (message "%s does not exist." fname))
  1586.    ((not (file-readable-p fname))
  1587.     (message "%s is unreadable." fname))
  1588.    (t
  1589.     (save-excursion
  1590.       (set-buffer (get-buffer-create " *url-tmp*"))
  1591.       (erase-buffer)
  1592.       (insert-file-contents-literally fname)
  1593.       (goto-char (point-min))
  1594.       (cond
  1595.        ((looking-at "(setq") (url-parse-Emacs-history fname))
  1596.        ((looking-at "ncsa-mosaic-.*-1$") (url-parse-Mosaic-history-v1 fname))
  1597.        ((looking-at "ncsa-mosaic-.*-2$") (url-parse-Mosaic-history-v2 fname))
  1598.        ((or (looking-at "MCOM-") (looking-at "netscape"))
  1599.     (url-parse-Netscape-history fname))
  1600.        (t
  1601.     (url-warn 'url (format "Cannot deduce type of history file: %s"
  1602.                    fname))))))))
  1603.  
  1604. (defun url-write-Emacs-history (fname)
  1605.   ;; Write an Emacs-w3 style global history list into FNAME
  1606.   (erase-buffer)
  1607.   (let ((count 0))
  1608.     (cl-maphash (function
  1609.          (lambda (key value)
  1610.            (while (string-match "[\r\n]+" key)
  1611.              (setq key (concat (substring key 0 (match-beginning 0))
  1612.                        (substring key (match-end 0) nil))))
  1613.            (setq count (1+ count))
  1614.            (insert "(cl-puthash \"" key "\""
  1615.                (if (not (stringp value)) " '" "")
  1616.                (prin1-to-string value)
  1617.                " url-global-history-hash-table)\n")))
  1618.         url-global-history-hash-table)
  1619.     (goto-char (point-min))
  1620.     (insert (format
  1621.          "(setq url-global-history-hash-table (make-hash-table :size %d :test 'equal))\n"
  1622.          (/ count 4)))
  1623.     (goto-char (point-max))
  1624.     (insert "\n")
  1625.     (write-file fname)))
  1626.  
  1627. (defun url-write-Netscape-history (fname)
  1628.   ;; Write a Netscape-style global history list into FNAME
  1629.   (erase-buffer)
  1630.   (let ((last-valid-time "785305714"))    ; Picked out of thin air,
  1631.                     ; in case first in assoc list
  1632.                     ; doesn't have a valid time
  1633.     (goto-char (point-min))
  1634.     (insert "MCOM-Global-history-file-1\n")
  1635.     (cl-maphash (function
  1636.          (lambda (url time)
  1637.            (if (or (not (stringp time)) (string-match " \t" time))
  1638.                (setq time last-valid-time)
  1639.              (setq last-valid-time time))
  1640.            (insert url " " time "\n")))
  1641.         url-global-history-hash-table)
  1642.     (write-file fname)))
  1643.  
  1644. (defun url-write-Mosaic-history-v1 (fname)
  1645.   ;; Write a Mosaic/X-style global history list into FNAME
  1646.   (erase-buffer)
  1647.   (goto-char (point-min))
  1648.   (insert "ncsa-mosaic-history-format-1\nGlobal\n")
  1649.   (cl-maphash (function
  1650.            (lambda (url time)
  1651.          (if (listp time)
  1652.              (setq time (current-time-string time)))
  1653.          (if (or (not (stringp time))
  1654.              (not (string-match " " time)))
  1655.              (setq time (current-time-string)))
  1656.          (insert url " " time "\n")))
  1657.           url-global-history-hash-table)
  1658.   (write-file fname))
  1659.  
  1660. (defun url-write-Mosaic-history-v2 (fname)
  1661.   ;; Write a Mosaic/X-style global history list into FNAME
  1662.   (let ((last-valid-time "827250806"))
  1663.     (erase-buffer)
  1664.     (goto-char (point-min))
  1665.     (insert "ncsa-mosaic-history-format-2\nGlobal\n")
  1666.     (cl-maphash (function
  1667.          (lambda (url time)
  1668.            (if (listp time)
  1669.                (setq time last-valid-time)
  1670.              (setq last-valid-time time))
  1671.            (if (not (stringp time))
  1672.                (setq time last-valid-time))
  1673.            (insert url " " time "\n")))
  1674.         url-global-history-hash-table)
  1675.     (write-file fname)))
  1676.  
  1677. (defun url-write-global-history (&optional fname)
  1678.   "Write the global history file into `url-global-history-file'.
  1679. The type of data written is determined by what is in the file to begin
  1680. with.  If the type of storage cannot be determined, then prompt the
  1681. user for what type to save as."
  1682.   (interactive)
  1683.   (or fname (setq fname (expand-file-name url-global-history-file)))
  1684.   (cond
  1685.    ((not url-history-changed-since-last-save) nil)
  1686.    ((not (file-writable-p fname))
  1687.     (message "%s is unwritable." fname))
  1688.    (t
  1689.     (let ((make-backup-files nil)
  1690.       (version-control nil)
  1691.       (require-final-newline t))
  1692.       (save-excursion
  1693.     (set-buffer (get-buffer-create " *url-tmp*"))
  1694.     (erase-buffer)
  1695.     (condition-case ()
  1696.         (insert-file-contents-literally fname)
  1697.       (error nil))
  1698.     (goto-char (point-min))
  1699.     (cond
  1700.      ((looking-at "ncsa-mosaic-.*-1$") (url-write-Mosaic-history-v1 fname))
  1701.      ((looking-at "ncsa-mosaic-.*-2$") (url-write-Mosaic-history-v2 fname))
  1702.      ((looking-at "MCOM-") (url-write-Netscape-history fname))
  1703.      ((looking-at "netscape") (url-write-Netscape-history fname))
  1704.      ((looking-at "(setq") (url-write-Emacs-history fname))
  1705.      (t (url-write-Emacs-history fname)))
  1706.     (kill-buffer (current-buffer))))))
  1707.   (setq url-history-changed-since-last-save nil))
  1708.  
  1709.  
  1710. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1711. ;;; The main URL fetching interface
  1712. ;;; -------------------------------
  1713. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1714.  
  1715. ;;;###autoload
  1716. (defun url-popup-info (url)
  1717.   "Retrieve the HTTP/1.0 headers and display them in a temp buffer."
  1718.   (let* ((urlobj (url-generic-parse-url url))
  1719.      (type (url-type urlobj))
  1720.      data)
  1721.     (cond
  1722.      ((string= type "http")
  1723.       (let ((url-request-method "HEAD")
  1724.         (url-automatic-caching nil)
  1725.         (url-inhibit-mime-parsing t)
  1726.         (url-working-buffer " *popup*"))
  1727.     (save-excursion
  1728.       (set-buffer (get-buffer-create url-working-buffer))
  1729.       (erase-buffer)
  1730.       (setq url-be-asynchronous nil)
  1731.       (url-retrieve url)
  1732.       (subst-char-in-region (point-min) (point-max) ?\r ? )
  1733.       (buffer-string))))
  1734.      ((or (string= type "file") (string= type "ftp"))
  1735.       (setq data (url-file-attributes url))
  1736.       (set-buffer (get-buffer-create
  1737.            (url-generate-new-buffer-name "*Header Info*")))
  1738.       (erase-buffer)
  1739.       (if data
  1740.       (concat (if (stringp (nth 0 data))
  1741.               (concat "    Linked to: " (nth 0 data))
  1742.             (concat "    Directory: " (if (nth 0 data) "Yes" "No")))
  1743.           "\n        Links: " (int-to-string (nth 1 data))
  1744.           "\n     File UID: " (int-to-string (nth 2 data))
  1745.           "\n     File GID: " (int-to-string (nth 3 data))
  1746.           "\n  Last Access: " (current-time-string (nth 4 data))
  1747.           "\nLast Modified: " (current-time-string (nth 5 data))
  1748.           "\n Last Changed: " (current-time-string (nth 6 data))
  1749.           "\n Size (bytes): " (int-to-string (nth 7 data))
  1750.           "\n    File Type: " (or (nth 8 data) "text/plain"))
  1751.     (concat "No info found for " url)))
  1752.      ((and (string= type "news") (string-match "@" url))
  1753.       (let ((art (url-filename urlobj)))
  1754.     (if (not (string= (substring art -1 nil) ">"))
  1755.         (setq art (concat "<" art ">")))
  1756.     (url-get-headers-from-article-id art)))
  1757.      (t (concat "Don't know how to find information on " url)))))
  1758.  
  1759. (defun url-decode-text ()
  1760.   ;; Decode text transmitted by NNTP.
  1761.   ;; 0. Delete status line.
  1762.   ;; 1. Delete `^M' at end of line.
  1763.   ;; 2. Delete `.' at end of buffer (end of text mark).
  1764.   ;; 3. Delete `.' at beginning of line."
  1765.   (save-excursion
  1766.     (set-buffer nntp-server-buffer)
  1767.     ;; Insert newline at end of buffer.
  1768.     (goto-char (point-max))
  1769.     (if (not (bolp))
  1770.     (insert "\n"))
  1771.     ;; Delete status line.
  1772.     (goto-char (point-min))
  1773.     (delete-region (point) (progn (forward-line 1) (point)))
  1774.     ;; Delete `^M' at end of line.
  1775.     ;; (replace-regexp "\r$" "")
  1776.     (while (not (eobp))
  1777.       (end-of-line)
  1778.       (if (= (preceding-char) ?\r)
  1779.       (delete-char -1))
  1780.       (forward-line 1)
  1781.       )
  1782.     ;; Delete `.' at end of buffer (end of text mark).
  1783.     (goto-char (point-max))
  1784.     (forward-line -1)            ;(beginning-of-line)
  1785.     (if (looking-at "^\\.$")
  1786.     (delete-region (point) (progn (forward-line 1) (point))))
  1787.     ;; Replace `..' at beginning of line with `.'.
  1788.     (goto-char (point-min))
  1789.     ;; (replace-regexp "^\\.\\." ".")
  1790.     (while (search-forward "\n.." nil t)
  1791.       (delete-char -1))
  1792.     ))
  1793.  
  1794. (defun url-get-headers-from-article-id (art)
  1795.   ;; Return the HEAD of ART (a usenet news article)
  1796.   (cond
  1797.    ((string-match "flee" nntp-version)
  1798.     (nntp/command "HEAD" art)
  1799.     (save-excursion
  1800.       (set-buffer nntp-server-buffer)
  1801.       (while (progn (goto-char (point-min))
  1802.             (not (re-search-forward "^.\r*$" nil t)))
  1803.     (url-accept-process-output nntp/connection))))
  1804.    (t
  1805.     (nntp-send-command "^\\.\r$" "HEAD" art)
  1806.     (url-decode-text)))
  1807.   (save-excursion
  1808.     (set-buffer nntp-server-buffer)
  1809.     (buffer-string)))
  1810.  
  1811. (defcustom url-external-retrieval-program "www"
  1812.   "*Name of the external executable to run to retrieve URLs."
  1813.   :type 'string
  1814.   :group 'url)
  1815.  
  1816. (defcustom url-external-retrieval-args '("-source")
  1817.   "*A list of arguments to pass to `url-external-retrieval-program' to
  1818. retrieve a URL by its HTML source."
  1819.   :type '(repeat string)
  1820.   :group 'url)
  1821.  
  1822. (defun url-retrieve-externally (url &optional no-cache)
  1823.   (let ((url-working-buffer (if (and url-multiple-p
  1824.                      (string-equal url-working-buffer
  1825.                            url-default-working-buffer))
  1826.                 (url-get-working-buffer-name)
  1827.                   url-working-buffer)))
  1828.     (if (get-buffer-create url-working-buffer)
  1829.     (save-excursion
  1830.       (set-buffer url-working-buffer)
  1831.       (set-buffer-modified-p nil)
  1832.       (kill-buffer url-working-buffer)))
  1833.     (set-buffer (get-buffer-create url-working-buffer))
  1834.     (let* ((args (append url-external-retrieval-args (list url)))
  1835.        (urlobj (url-generic-parse-url url))
  1836.        (type (url-type urlobj)))
  1837.       (if (or (member type '("www" "about" "mailto" "mailserver"))
  1838.           (url-file-directly-accessible-p urlobj))
  1839.       (url-retrieve-internally url)
  1840.     (url-lazy-message "Retrieving %s..." url)
  1841.     (apply 'call-process url-external-retrieval-program
  1842.            nil t nil args)
  1843.     (url-lazy-message "Retrieving %s... done" url)))))
  1844.  
  1845. (defun url-get-normalized-date (&optional specified-time)
  1846.   ;; Return a 'real' date string that most HTTP servers can understand.
  1847.   (require 'timezone)
  1848.   (let* ((raw (if specified-time (current-time-string specified-time)
  1849.         (current-time-string)))
  1850.      (gmt (timezone-make-date-arpa-standard raw
  1851.                         (nth 1 (current-time-zone))
  1852.                         "GMT"))
  1853.      (parsed (timezone-parse-date gmt))
  1854.      (day (cdr-safe (assoc (substring raw 0 3) weekday-alist)))
  1855.      (year nil)
  1856.      (month (car
  1857.          (rassoc
  1858.           (string-to-int (aref parsed 1)) monthabbrev-alist)))
  1859.      )
  1860.     (setq day (or (car-safe (rassoc day weekday-alist))
  1861.           (substring raw 0 3))
  1862.       year (aref parsed 0))
  1863.     ;; This is needed for plexus servers, or the server will hang trying to
  1864.     ;; parse the if-modified-since header.  Hopefully, I can take this out
  1865.     ;; soon.
  1866.     (if (and year (> (length year) 2))
  1867.     (setq year (substring year -2 nil)))
  1868.  
  1869.     (concat day ", " (aref parsed 2) "-" month "-" year " "
  1870.         (aref parsed 3) " " (or (aref parsed 4)
  1871.                     (concat "[" (nth 1 (current-time-zone))
  1872.                         "]")))))
  1873.  
  1874. (defun url-get-working-buffer-name ()
  1875.   "Get a working buffer name such as ` *URL-<i>*' without a live process and empty"
  1876.   (let ((num 1)
  1877.     name buf)
  1878.     (while (progn (setq name (format " *URL-%d*" num))
  1879.           (setq buf (get-buffer name))
  1880.           (and buf (or (get-buffer-process buf)
  1881.                    (save-excursion (set-buffer buf)
  1882.                            (> (point-max) 1)))))
  1883.       (setq num (1+ num)))
  1884.     name))
  1885.  
  1886. (defun url-default-find-proxy-for-url (urlobj host)
  1887.   (cond
  1888.    ((or (and (assoc "no_proxy" url-proxy-services)
  1889.          (string-match
  1890.           (cdr
  1891.            (assoc "no_proxy" url-proxy-services))
  1892.           host))
  1893.     (equal "www" (url-type urlobj)))
  1894.     "DIRECT")
  1895.    ((cdr (assoc (url-type urlobj) url-proxy-services))
  1896.     (concat "PROXY " (cdr (assoc (url-type urlobj) url-proxy-services))))
  1897.    ;;
  1898.    ;; Should check for socks
  1899.    ;;
  1900.    (t
  1901.     "DIRECT")))
  1902.  
  1903. (defvar url-proxy-locator 'url-default-find-proxy-for-url)
  1904.  
  1905. (defun url-find-proxy-for-url (url host)
  1906.   (let ((proxies (split-string (funcall url-proxy-locator url host) " *; *"))
  1907.     (proxy nil)
  1908.     (case-fold-search t))
  1909.     ;; Not sure how I should handle gracefully degrading from one proxy to
  1910.     ;; another, so for now just deal with the first one
  1911.     ;; (while proxies
  1912.     (if (listp proxies)
  1913.     (setq proxy (pop proxies))
  1914.       (setq proxy proxies))
  1915.     (cond
  1916.      ((string-match "^direct" proxy) nil)
  1917.      ((string-match "^proxy +" proxy)
  1918.       (concat "http://" (substring proxy (match-end 0)) "/"))
  1919.      ((string-match "^socks +" proxy)
  1920.       (concat "socks://" (substring proxy (match-end 0))))
  1921.      (t
  1922.       (url-warn 'url (format "Unknown proxy directive: %s" proxy) 'critical)
  1923.       nil))))
  1924.  
  1925. (defun url-retrieve-internally (url &optional no-cache)
  1926.   (let* ((url-working-buffer (if (and url-multiple-p
  1927.                       (string-equal
  1928.                        (if (bufferp url-working-buffer)
  1929.                        (buffer-name url-working-buffer)
  1930.                      url-working-buffer)
  1931.                        url-default-working-buffer))
  1932.                  (url-get-working-buffer-name)
  1933.                    url-working-buffer))
  1934.      (urlobj (url-generic-parse-url url))
  1935.      (type (url-type urlobj))
  1936.      (url-using-proxy (if (url-host urlobj)
  1937.                   (url-find-proxy-for-url urlobj
  1938.                               (url-host urlobj))
  1939.                 nil))
  1940.      (handler nil)
  1941.      (original-url url)
  1942.      (cached nil))
  1943.     (if url-using-proxy (setq type "proxy"))
  1944.     (setq cached (url-is-cached url)
  1945.       cached (and cached (not (url-cache-expired url cached)))
  1946.       handler (if cached
  1947.               'url-cache-extract
  1948.             (car-safe
  1949.              (cdr-safe (assoc (or type "auto")
  1950.                       url-registered-protocols))))
  1951.       url (if cached (url-cache-create-filename url) url))
  1952.     (save-excursion
  1953.       (set-buffer (get-buffer-create url-working-buffer))
  1954.       (if (boundp 'buffer-file-coding-system)
  1955.       (setq buffer-file-coding-system nil))
  1956.       (setq url-current-can-be-cached (not no-cache)
  1957.         url-current-object urlobj))
  1958.     (if (and handler (fboundp handler))
  1959.     (funcall handler url)
  1960.       (set-buffer (get-buffer-create url-working-buffer))
  1961.       (erase-buffer)
  1962.       (setq url-current-mime-type "text/html")
  1963.       (insert "<title> Link Error! </title>\n"
  1964.           "<h1> An error has occurred... </h1>\n"
  1965.           (format "The link type `<code>%s</code>'" type)
  1966.           " is unrecognized or unsupported at this time.<p>\n"
  1967.           "If you feel this is an error in Emacs-W3, please "
  1968.           "<a href=\"mailto://" url-bug-address "\">send me mail.</a>"
  1969.           "<p><address>William Perry</address><br>"
  1970.           "<address>" url-bug-address "</address>"))
  1971.     (cond
  1972.      ((and url-be-asynchronous (not cached)
  1973.        (member type '("http" "https" "proxy" "file" "ftp")))
  1974.       nil)
  1975.      ((and url-be-asynchronous (get-buffer url-working-buffer))
  1976.       (funcall url-default-retrieval-proc (buffer-name)))
  1977.      ((not (get-buffer url-working-buffer)) nil)
  1978.      ((and (not url-inhibit-mime-parsing)
  1979.        (or cached (url-mime-response-p t)))
  1980.       (or cached (url-parse-mime-headers nil t))))
  1981.     (if (and (or (not url-be-asynchronous)
  1982.          (not (equal type "http")))
  1983.          url-current-object
  1984.          (not url-current-mime-type))
  1985.     (setq url-current-mime-type (mm-extension-to-mime
  1986.                      (url-file-extension
  1987.                       (url-filename
  1988.                        url-current-object)))))
  1989.     (if (not url-be-asynchronous)
  1990.     (url-store-in-cache url-working-buffer))
  1991.     (if (not url-global-history-hash-table)
  1992.     (setq url-global-history-hash-table (make-hash-table :size 131
  1993.                                  :test 'equal)))
  1994.     (if (not (string-match "^\\(about\\|www\\):" original-url))
  1995.     (progn
  1996.       (setq url-history-changed-since-last-save t)
  1997.       (cl-puthash original-url (current-time)
  1998.               url-global-history-hash-table)))
  1999.     (cons cached url-working-buffer)))
  2000.  
  2001. ;;;###autoload
  2002. (defun url-retrieve (url &optional no-cache expected-md5)
  2003.   "Retrieve a document over the World Wide Web.
  2004. The document should be specified by its fully specified
  2005. Uniform Resource Locator.  No parsing is done, just return the
  2006. document as the server sent it.  The document is left in the
  2007. buffer specified by url-working-buffer.  url-working-buffer is killed
  2008. immediately before starting the transfer, so that no buffer-local
  2009. variables interfere with the retrieval.  HTTP/1.0 redirection will
  2010. be honored before this function exits."
  2011.   (url-do-setup)
  2012.   ;;(url-download-minor-mode t)
  2013.   (if (and (fboundp 'set-text-properties)
  2014.        (subrp (symbol-function 'set-text-properties)))
  2015.       (set-text-properties 0 (length url) nil url))
  2016.   (if (and url (string-match "^url:" url))
  2017.       (setq url (substring url (match-end 0) nil)))
  2018.   (let ((status (url-retrieve-internally url no-cache)))
  2019.     status))
  2020.  
  2021. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2022. ;;; How to register a protocol
  2023. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2024. (defun url-register-protocol (protocol &optional retrieve expander defport)
  2025.   "Register a protocol with the URL retrieval package.
  2026. PROTOCOL is the type of protocol being registers (http, nntp, etc),
  2027.          and is the first chunk of the URL.  ie: http:// URLs will be
  2028.          handled by the protocol registered as 'http'.  PROTOCOL can
  2029.          be either a symbol or a string - it is converted to a string,
  2030.          and lowercased before being registered.
  2031. RETRIEVE (optional) is the function to be called with a url as its
  2032.          only argument.  If this argument is omitted, then this looks
  2033.          for a function called 'url-PROTOCOL'.  A warning is shown if
  2034.          the function is undefined, but the protocol is still
  2035.          registered.
  2036. EXPANDER (optional) is the function to call to expand a relative link
  2037.          of type PROTOCOL.  If omitted, this defaults to
  2038.          `url-default-expander'
  2039.  
  2040. Any proxy information is read in from environment variables at this
  2041. time, so this function should only be called after dumping emacs."
  2042.   (let* ((protocol (cond
  2043.             ((stringp protocol) (downcase protocol))
  2044.             ((symbolp protocol) (downcase (symbol-name protocol)))
  2045.             (t nil)))
  2046.              
  2047.      (retrieve (or retrieve (intern (concat "url-" protocol))))
  2048.      (expander (or expander 'url-default-expander))
  2049.      (cur-protocol (assoc protocol url-registered-protocols))
  2050.      (urlobj nil)
  2051.      (cur-proxy (assoc protocol url-proxy-services))
  2052.      (env-proxy (or (getenv (concat protocol "_proxy"))
  2053.             (getenv (concat protocol "_PROXY"))
  2054.             (getenv (upcase (concat protocol "_PROXY"))))))
  2055.  
  2056.     (if (not protocol)
  2057.     (error "Invalid data to url-register-protocol."))
  2058.     
  2059.     (if (not (fboundp retrieve))
  2060.     (message "Warning: %s registered, but no function found." protocol))
  2061.  
  2062.     ;; Store the default port, if none previously specified and
  2063.     ;; defport given
  2064.     (if (and defport (not (assoc protocol url-default-ports)))
  2065.     (setq url-default-ports (cons (cons protocol defport)
  2066.                       url-default-ports)))
  2067.     
  2068.     ;; Store the appropriate information for later
  2069.     (if cur-protocol
  2070.     (setcdr cur-protocol (cons retrieve expander))
  2071.       (setq url-registered-protocols (cons (cons protocol
  2072.                          (cons retrieve expander))
  2073.                        url-registered-protocols)))
  2074.  
  2075.     ;; Store any proxying information - this will not overwrite an old
  2076.     ;; entry, so that people can still set this information in their
  2077.     ;; .emacs file
  2078.     (cond
  2079.      (cur-proxy nil)            ; Keep their old settings
  2080.      ((null env-proxy) nil)        ; No proxy setup
  2081.      ;; First check if its something like hostname:port
  2082.      ((string-match "^\\([^:]+\\):\\([0-9]+\\)$" env-proxy)
  2083.       (setq urlobj (url-generic-parse-url nil)) ; Get a blank object
  2084.       (url-set-type urlobj "http")
  2085.       (url-set-host urlobj (url-match env-proxy 1))
  2086.       (url-set-port urlobj (url-match env-proxy 2)))
  2087.      ;; Then check if its a fully specified URL
  2088.      ((string-match url-nonrelative-link env-proxy)
  2089.       (setq urlobj (url-generic-parse-url env-proxy))
  2090.       (url-set-type urlobj "http")
  2091.       (url-set-target urlobj nil))
  2092.      ;; Finally, fall back on the assumption that its just a hostname
  2093.      (t
  2094.       (setq urlobj (url-generic-parse-url nil)) ; Get a blank object
  2095.       (url-set-type urlobj "http")
  2096.       (url-set-host urlobj env-proxy)))
  2097.  
  2098.      (if (and (not cur-proxy) urlobj)
  2099.      (progn
  2100.        (setq url-proxy-services
  2101.          (cons (cons protocol (concat (url-host urlobj) ":"
  2102.                           (url-port urlobj)))
  2103.                url-proxy-services))
  2104.        (message "Using a proxy for %s..." protocol)))))
  2105.  
  2106. (provide 'url)
  2107.